home *** CD-ROM | disk | FTP | other *** search
/ Power Programmierung / Power-Programmierung (Tewi)(1994).iso / magazine / drdobbs / 1987 / 04 / hamlst.lst < prev    next >
File List  |  1987-03-12  |  10KB  |  285 lines
  1. ( Elemental tools                          Ham 10:31 12/13/86 )
  2.  
  3. : -CUR  14  0 SET-CURSOR ;  ( no cursor )
  4. : +CUR   6  7 SET-CURSOR ;  ( normal cursor )
  5.  
  6. : BACK   ( n - ) 0 ?DO 8 EMIT LOOP ;  ( backspace word )
  7.  
  8.    0 CONSTANT NEW  ( to collect new digits )
  9.   -1 CONSTANT OLD  ( to provide existing number to routine )
  10.  
  11. : INCR  ( a - )   1 SWAP +! ;  ( increments variable )
  12. : DECR  ( a - )  -1 SWAP +! ;  ( decrements variable )
  13.  
  14. : Bs? ( n - f )  8 = ;   ( T if backspace pressed )
  15. : Cr? ( n - f ) 13 = ;   ( T if carriage return pressed )
  16.  
  17.   VARIABLE OK-NEG  ( T allows for entry of - ; F rejects - )
  18.   VARIABLE SOUND   ( T if using sound )
  19.  
  20. : BELL ( - ) SOUND @  IF   440  8 BEEP ( short beep ) THEN ;
  21.  
  22.  
  23.   CREATE #PAD 15 ALLOT  ( work area )
  24.  
  25. : #P! ( c n - )  #PAD + C! ; ( stores character c at offset n )
  26.  
  27.   CREATE #VAR 14 ALLOT      ( holds various values             )
  28.  
  29.   #VAR      CONSTANT #DEC   ( no. of fractional digits ALLOWED )
  30.   #VAR  2+  CONSTANT #dec   ( no. of fractional digits ENTERED )
  31.   #VAR  4 + CONSTANT #WHOLE ( no. of whole digits entered      )
  32.   #VAR  6 + CONSTANT #HIT   ( no. of keystrokes                )
  33.   #VAR  8 + CONSTANT NEG~   ( T if number is negative          )
  34.   #VAR 10 + CONSTANT dec~   ( T if decimal point entered       )
  35.   #VAR 12 + CONSTANT DIGCNT ( counts no. of digits for old nos.)
  36.  
  37. : PLACES ( n - ) #DEC ! ; ( sets # of decimal places allowed )
  38.  
  39. : #init  #dec 12 ERASE ( don't erase #DEC ) #PAD 15 ERASE ;
  40.  
  41. : *HIT/NEG  #HIT 4 ERASE ;  ( resets no. hit and negative flag )
  42.  
  43. : NEG? ( - f )  NEG~ @ ; ( T if number is negative )
  44.  
  45. : dec? ( - f )  dec~ @ ; ( T if dec point entered )
  46.  
  47.  
  48.  
  49. ( Get and edit keystroke                   Ham 10:33 12/13/86 )
  50.  
  51. : CAPITALIZE ( c - C )  DUP 96 > OVER 123 < AND IF BL - THEN ;
  52.  
  53. : FIXUP ( c-c) DUP ASCII B = OVER BL = OR IF DROP ASCII C THEN
  54.         ( convert B and space bar to C := clear number entry )
  55.         ( L := 1 ) DUP ASCII L = IF DROP ASCII 1 THEN
  56.         ( O := 0 ) DUP ASCII O = IF DROP ASCII 0 THEN ;
  57.  
  58. : #?  ( n - f ) DUP ASCII / > SWAP ASCII : < AND ; ( T if digit)
  59.  
  60. : BAD? ( n - f ) DUP #?  OK-NEG @  IF OVER ASCII - = OR THEN
  61.                          #DEC   @  IF OVER ASCII . = OR THEN
  62.              OVER ASCII C = OR  OVER Bs? OR  SWAP Cr? OR  NOT ;
  63.  
  64. : GET#  ( - n) BEGIN KEY CAPITALIZE FIXUP DUP BAD?
  65.                WHILE DROP BELL REPEAT ;
  66.  
  67.  
  68.  
  69. ( Collection box                           Ham 10:34 12/13/86 )
  70.  
  71. : #,S ( #w - #, ) 3 /MOD SWAP 0= + 0 MAX ;
  72.   ( takes # of whole-number digits, leaves # of commas required)
  73.   ( Warning:  Assumes 83-Std flag = -1; negate flag if 79 Std )
  74.  
  75. : FULLCNT ( n - n' ) #DEC @ IF 1+ THEN  OK-NEG @ IF 1+ THEN ;
  76.     ( adds to char cnt the decimal point and minus sign if any )
  77.  
  78. : BOXSIZE ( n - m ) DUP ( # of digits ) #DEC @ - ( #whole digts)
  79.    DUP 1 < ( T if no whole digits ) NEGATE ( 83-Std flag ) >R
  80.    #,S ( # of commas )  R> + +   2+ ( space at either end )
  81.    FULLCNT ; ( leaves number of character in box )
  82.  
  83. : BOX  ( n - ) BOXSIZE SPACES ;
  84.        ( prints inverse spaces to define field for number entry)
  85.  
  86.  
  87.  
  88. ( Sign/decimal                             Ham 10:34 12/13/86 )
  89.  
  90. : -.  ( displays - or . or both when no digits yet entered )
  91.       NEG? dec? AND IF 3 BACK ." -. "
  92.                     ELSE NEG? IF 2 BACK ." - "
  93.                               ELSE dec? IF 2 BACK ." . "
  94.       THEN THEN THEN ;
  95.  
  96.  
  97.  
  98. ( Count digits; show number                Ham 10:35 12/13/86 )
  99.  
  100. : 2, ( d - ) , , ;  ( store double into dictionary )
  101.  
  102.   CREATE NINES  9. 2,  99. 2,  999. 2,  9999. 2,  99999. 2,
  103.    999999. 2,  9999999. 2,  99999999. 2,  999999999. 2,
  104.  
  105. : #OFDIGITS ( d - # ) DABS 1 DIGCNT !
  106.       BEGIN 2DUP DIGCNT @ 1- 4 * NINES + 2@ D>
  107.       WHILE DIGCNT INCR REPEAT 2DROP DIGCNT @ ;
  108.  
  109. : PUT#  ( - adr cnt ) ( prepares number for display )
  110.     0. #PAD 1- CONVERT DROP 2DUP #OFDIGITS >R
  111.     <#  dec?  IF #dec @  0 ?DO # LOOP ASCII . HOLD THEN
  112.         R> #dec @ - #,S  0 ?DO # # #  ASCII , HOLD LOOP
  113.         #S NEG? SIGN #> ;
  114.  
  115.  
  116. ( Display the number nicely                Ham 19:39 12/04/86 )
  117.  
  118. : DISPLAY# ( n - n ) DUP ( get another copy of max # of digits )
  119.    BOXSIZE DUP BACK
  120.    ( back up to beginning of entry field; top of stack is )
  121.    ( size of box, which is greater than # of digits )
  122.    #HIT @
  123.     IF 1- ( space at end ) PUT# ROT OVER - SPACES TYPE SPACE
  124.     ELSE SPACES ( new box ) -. THEN  ;
  125.    ( n is max no. of digits to be entered, which stays on stk )
  126.  
  127.  
  128.  
  129. ( Wrap-up routine                          Ham 21:15 11/27/86 )
  130.  
  131. : 10D*  ( d - 10*d ) 2DUP 2DUP D+ 2DUP D+ D+ 2DUP D+ ;
  132.  
  133. : SCALE#  #DEC @ ?DUP IF #dec @ -  0 ?DO 10D* LOOP THEN ;
  134.   ( scale up to integer from decimal fraction )
  135.  
  136. : #DONE  ( - d # )
  137.     ( leaves double number entered and no. of digits entered )
  138.     ( no. of digits = zero means no digits entered )
  139.     0. #PAD 1- CONVERT ( leaves addr of 1st nonconverting char )
  140.     #PAD - ( number of digits ) >R
  141.     NEG? IF DNEGATE THEN   SCALE#  R> DUP 0=
  142.        IF ( number is 0, see whether key pressed or no entry )
  143.          DROP #HIT @ 0> NEGATE ( Note:  83-Std flag ) THEN ;
  144.  
  145.  
  146. ( Adjust counts                            Ham 18:51 11/06/86 )
  147.  
  148. : #dec-ADJ    #dec @ IF #dec DECR THEN ; ( down one decimal )
  149.  
  150. : #WHOLE-ADJ  dec? NOT IF #WHOLE DECR THEN ; ( down 1 whole no.)
  151.  
  152. : NO-.? ( - f ) #HIT @ 0= NEG? 0= dec? 0= AND AND ;
  153.  
  154.  
  155.  
  156. ( When decimal point is hit                Ham 18:53 11/06/86 )
  157.  
  158. : .ROUTINE  dec? IF   BELL    ( decimal point already entered )
  159.                  ELSE dec~ ON ( mark entry of decimal point )
  160.                  THEN ;
  161.  
  162.  
  163.  
  164. ( Check if need to adjust digits           Ham 18:23 11/06/86 )
  165.  
  166.  ( WHOLE-CK & DEC-CK have this stack diagram: ( n f - n f' )
  167.  ( where n is the no. of digits entered so far )
  168.  
  169. : WHOLE-CK dec? 0= IF OVER #DEC @ - #WHOLE @ = OR THEN ;
  170.   ( makes flag T if dec pt not entered AND we have all the )
  171.   ( whole number digits that we can accept )
  172.  
  173. : DEC-CK   #DEC @ ?DUP IF #dec @ = OR THEN ;
  174.   ( makes flag T if we have all the digits to the right )
  175.   ( of the decimal that we can accept )
  176.  
  177.   ( The true flag will cause the latest digit entered to be )
  178.   ( dropped and the bell to sound (if SOUND is on)
  179.  
  180.  
  181.  
  182. ( Count each digit entered                 Ham 18:24 11/06/86 )
  183.  
  184.   VARIABLE 0START ( T if starting with whole number zero )
  185.  
  186.   ( A starting whole number value of zero is in effect a     )
  187.   ( leading zero and should not be counted in the total of   )
  188.   ( digits entered, or else the final numeric digit will not )
  189.   ( be accepted. )
  190.  
  191. : CNT-DIGIT dec? IF   #dec INCR
  192.                  ELSE 0START @ IF   0START OFF ( 1-time switch )
  193.                                ELSE #WHOLE INCR THEN THEN ;
  194.  
  195.  
  196.  
  197. ( Initialization for "old" numbers         Ham 18:26 11/06/86 )
  198.  
  199.   ( If old number is decimal, all places are present. )
  200.  
  201. : SET-dec  #DEC @ ?DUP IF #dec ! dec~ ON THEN ;
  202.  
  203. : SET-NEG ( d n - n d ) ROT ROT ( move dbl to top ) 2DUP 0. D<
  204.      IF ( neg: convert and note sign ) DNEGATE NEG~ ON THEN ;
  205.  
  206.   ( Put number into #PAD as an string of ASCII values: )
  207.  
  208. : SET-#P ( d - ) <# dec? IF #dec @ 0 DO # LOOP THEN
  209.     DIGCNT @ #DEC @ > IF #S THEN #> #PAD SWAP CMOVE ;
  210.  
  211.  
  212.  
  213. ( Initializes for loop                     Ham 18:34 11/06/86 )
  214.  
  215. : DSET ( d # T|# F -- m n p )
  216.   ( m = # of digits to collect, n p = limits for loop )
  217.   0START OFF #init OVER BOX
  218.   IF ( old number present ) SET-dec SET-NEG 2DUP
  219.     2DUP OR 0= #DEC @ 0= AND ( double is both zero and whole )
  220.       IF 0START ON THEN      ( so mark it as a zero start    )
  221.     #OFDIGITS #DEC @ MAX DUP #HIT ! ( set # of digits entered )
  222.     DUP #DEC @ - 0 MAX #WHOLE !     ( set # of whole digits ent)
  223.     ROT ROT SET-#P                  ( make & save ASCII string )
  224.     SWAP DUP 1+ ROT 0START @ +      ( using 83-Std flag to decr)
  225.   ELSE ( no old number present ) DUP 1+ 0 THEN  ;
  226.  
  227.  
  228.  
  229. ( Backspace routine                        Ham 10:35 12/13/86 )
  230.  
  231.   VARIABLE INDX ( holds index from loop )
  232.  
  233. : "I" ( - index ) INDX @ ;  ( lets me get I from outside loop )
  234.  
  235. : NO#?  ( - f) #HIT @ 0= ;  ( T = no digits entered )
  236.  
  237. : BSP-ROU ( -- loop-incr ) dec? #dec @ 0= AND
  238.     IF dec~ OFF 0  ( just backed over the decimal point )
  239.     ELSE "I" IF 0 "I" 1- #P! ( zap previous entry in string )
  240.                 #HIT DECR #dec-ADJ #WHOLE-ADJ ( adjust counts )
  241.                 NO-.?   ( no minus sign or decimal point? )
  242.                    IF   BELL "I" NEGATE  ( back up all the way )
  243.                    ELSE NO#? IF   "I" NEGATE
  244.                              ELSE -1 THEN THEN
  245.              ELSE *HIT/NEG BELL 0 THEN THEN ;
  246.  
  247. ( The above above takes care of the details of the backspace in
  248.   numeric entry & leaves the proper loop increment on the stk )
  249.  
  250.  
  251. ( Final input word                         Ham 18:51 11/06/86 )
  252.  
  253. : DIGITS ( d # T | # F -- d #) REVERSE DSET DO DISPLAY# GET#
  254.       DUP Bs?        IF DROP I INDX !  BSP-ROU
  255.  ELSE DUP ASCII - =  IF DROP NEG~ @ NOT NEG~ ! 0
  256.  ELSE DUP ASCII . =  IF DROP .ROUTINE 0
  257.  ELSE DUP ASCII C =  IF DROP #PAD C@ ASCII 0 <>
  258.                         IF #HIT @ NEGATE  ELSE 0 THEN  #init
  259.  ELSE DUP I #P! ( store char )  Cr? IF LEAVE THEN
  260.       I 1+ #HIT ! ( count of net keystrokes )
  261.       DUP ( # of digits to enter ) I = WHOLE-CK DEC-CK
  262.           IF ( at end: reject digit )  0 I #P!  I #HIT ! BELL 0
  263.           ELSE #PAD I + C@ ASCII 0 <> I 0<> OR dec? OR
  264.                NEGATE ( 83 Std flag )  DUP  IF CNT-DIGIT THEN
  265.    THEN THEN THEN THEN THEN +LOOP
  266.  DROP ( count ) #DONE REVERSE ;
  267.  
  268.  
  269. ( Test                                     Ham 18:51 11/06/86 )
  270.  
  271.   0 PLACES
  272.   OK-NEG OFF
  273.   SOUND ON
  274.   -CUR
  275.  
  276.   5 NEW DIGITS
  277.  
  278.   CR CR
  279.   2 PLACES
  280.   OK-NEG ON
  281.  
  282.   7 NEW DIGITS
  283.  
  284.   +CUR
  285.